home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Magnum One
/
Magnum One (Mid-American Digital) (Disc Manufacturing).iso
/
d26
/
cattest.arc
/
CHECKANS.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-07-01
|
6KB
|
199 lines
unit checkans;
{$UNDEF debug }
(* remarks - October 5, 1990; added functions with open bracket
search
*)
interface
uses Crt,Utility,Eval3;
VAR
MyErrTyp,MyErrPos : Integer;
MyErrMsg : STRING;
uc_var : char;
FUNCTION Check_Answer(s1,s2:STRING;tolerance:real): BOOLEAN;
implementation
FUNCTION Check_Answer(s1,s2:STRING;tolerance:real): BOOLEAN;
VAR
rno : REAL;
arno : STRING[8];
k,k1,l : INTEGER;
const_val : ARRAY[1..26] OF STRING;
PROCEDURE EXCISE(VAR s:STRING;arno:STRING);
LABEL exit_this_loop;
CONST
builtinNames : ARRAY [1..19] OF STRING
= ('abs(', 'round(', 'trunc(', 'sqrt(', 'sqr(',
'arcsin(', 'arccos(', 'arctan(', 'sinh(', 'cosh(', 'tanh(',
'sin(', 'cos(', 'tan(',
'ln(', 'log(', 'log2(', 'exp(', 'fact(');
VAR
s2,s_mask : STRING;
k_pos,
k,k_loc,k_len,count : integer;
procedure mask_string;
var k : integer;
CONST
Numbers : set of char = ['0'..'9','.'];
begin
s_mask := '';
if s[1] in Numbers then s := '(' + s + ')';
if s[length(s)] in Numbers then s:= '(' + s + ')';
FOR k := 1 to Length(s) do (* mask off interface between numbers
and other characters *)
if s[k] in ['0'..'9','.'] then s_mask := s_mask + '0' else
s_mask := s_mask + '1';
end;
BEGIN (*1*)
(*first enclose numbers in parenthesis*)
mask_string;
k := pos('01',s_mask);
while k > 0 do
begin
insert(')',s,k+1);
insert(')',s_mask,k+1);
k := pos('01',s_mask);
end;
k := pos('10',s_mask);
while k > 0 do
begin
insert('(',s,k+1);
insert('(',s_mask,k+1);
k := pos('10',s_mask);
end;
FOR k := 1 TO 19 DO
BEGIN(*2*)
k_loc := pos(builtinNames[k],s);
WHILE k_loc > 0 DO
BEGIN (*3*)
FOR k_len := 0 TO Length(builtinNames[k] )-2 DO
s[k_len+k_loc] := chr(ord(s[k_len+k_loc]) OR $80) ;
insert('(',s,k_loc); {enclose function in brackets}
count := 0;
FOR k_len := k_loc+Length(builtinNames[k]) TO Length(s) DO
BEGIN (*4*)
IF s[k_len] = '('
THEN inc(count);
IF s[k_len] = ')'
THEN dec(count);
IF count = 0
THEN
BEGIN (*5*)
insert(')',s,k_len+1);
GOTO exit_this_loop;
END;(*5*)
END; (*4*)
exit_this_loop:
k_loc := pos(builtinNames[k],s);
END; (*3*)
END; (*2*)
{once all functions are 8-bit highed, uppercase for constants}
FOR k := 1 TO length(s) DO
s[k] := UpCase(s[k]);
repeat
l := LENGTH(s);
k := POS(uc_var,s);
s2 := COPY(s,1,k-1)+'('+arno+')'+COPY(s,k+1,l-k); { if variable
present, then
replace with random
number surrounded
in brackets }
s := s2;
k := POS(uc_var,s);
UNTIL k = 0; {continue until variable gone}
{now eliminate all constants 'A' .. 'Z', assuming one letter, except
for the variable itself}
FOR k := 1 TO 26 DO
BEGIN
k_loc := pos(CHR(k+64),s);
WHILE k_loc <> 0 DO
BEGIN
s := COPY(s,1,k_loc-1)+'('+const_val[k]+')'+COPY(s,k_loc+1,length(s));
k_loc := pos(CHR(k+64),s);
END;
END;
(* REPEAT
s2 := '';
IF (s[k-1] IN ['0'..'9','.']) AND (k>1)
THEN insert('*',s,k); {example 7X -> 7*X}
IF (s[k+1] IN ['0'..'9','.']) AND (k+1<=l)
THEN insert('*',s,k+1); {example X9 -> X*9}
*)
FOR k_len := 1 TO length(s) DO
s[k_len] := chr(ord(s[k_len]) AND $7F) ; {restore builtin functions}
k_pos := POS(')(',s);
WHILE k_pos > 0 DO
BEGIN
insert('*',s,k_pos+1);
k_pos := POS(')(',s);
END;
k_pos := POS('()',s);
WHILE k_pos > 0 DO
BEGIN
DELETE (s,k_pos,2);
k_pos := POS('()',s);
END;
END;
VAR
Value1,Value2 : REAL;
BEGIN
FOR k := 1 TO 26 DO
STR(RANDOM:8:7,const_val[k]); (*initialize
constant's
substitution list*)
Check_Answer := FALSE;
k := POS(uc_var,s1);
rno := RANDOM;
STR(rno:8:7,arno);(*initialize variable's substitution*)
EXCISE(s1,arno);
Value1 := RANDOM;
Evaluate(s1,Value1,MyErrPos,MyErrMsg);
{$IFDEF debug}
GoToXY(1,15);
WriteLn('s1 = ',s1);
WriteLn('Value1 = ',Value1);
Pause(1,25,'Press any key to continue.');
{$ENDIF}
IF MyErrPos <> 0
THEN
exit
ELSE
BEGIN
EXCISE(s2,arno);
Value2 := RANDOM;
Evaluate(s2,Value2,MyErrPos,MyErrMsg);
IF MyErrPos <> 0
THEN
exit;
{$IFDEF debug}
GoToXY(1,17);
WriteLn('s2 = ',s2);
WriteLn('Value2 = ',Value2);
Pause(1,25,'Press any key to continue.');
{$ENDIF}
IF abs(Value1-Value2) <= tolerance
THEN Check_Answer := TRUE;
END;
END; {end Check_Answer}
END.